home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #2 / Ham Radio 2000 - Volume 2.iso / HAMV2 / MISC / HCAL-27 / DAYS.BAS (.txt) < prev    next >
Encoding:
GW-BASIC  |  1997-01-30  |  5.4 KB  |  223 lines
  1. 10  'DAYS - 30 SEP 89 - last rev. 30 JAN 97
  2. 20  'REM - chained from "CALTODAY"
  3. 30  IF EX$=""THEN EX$="EXIT"
  4. 40  COMMON EX$
  5. 50  '
  6. 60  CLS
  7. 70  DIM A$(12),M$(12)
  8. 80  LOCATE ,,0      'cursor off
  9. 90  KEY OFF
  10. 100  COLOR 7,0,0
  11. 110  U1$=STRING$(80,205)
  12. 120  U2$=STRING$(80,196)
  13. 130  E$=STRING$(80,32)
  14. 140  Z$=DATE$
  15. 150  Y=VAL(RIGHT$(Z$,4))
  16. 160  M=VAL(LEFT$(Z$,2))
  17. 170  D=VAL(MID$(Z$,4,2))
  18. 180  GOSUB 1010
  19. 190  MM=M
  20. 200  GOSUB 1200
  21. 210  '
  22. 220  '.....start
  23. 230  CLS
  24. 240  PRINT TAB(31);"DAYS BETWEEN DATES"
  25. 250  PRINT U1$;
  26. 260  GOSUB 1980
  27. 270  INPUT " Start Year ............";R
  28. 280  IF R<1753 THEN GOSUB 960:GOTO 80
  29. 290  GOSUB 2040
  30. 300  PRINT "        Start Year ..............";USING "####";R
  31. 310  GOSUB 1980
  32. 320  INPUT " Start Month No. .......";S
  33. 330  GOSUB 2040
  34. 340  PRINT "        Start Month No. .........";USING "####";S
  35. 350  MM=S:GOSUB 1200
  36. 360  GOSUB 1980
  37. 370  INPUT " Start Day No. .........";T
  38. 380  Y=R:M=S:D=T:GOSUB 1010:A$(7)=J$(Z)
  39. 390  LOCATE CSRLIN-3
  40. 400  PRINT "Start date ................ ";A$(7);" "W$;STR$(T);",";R
  41. 410  PRINT U2$;:PRINT E$;:LOCATE CSRLIN-1
  42. 420  '
  43. 430  GOSUB 1980
  44. 440  INPUT " End Year ..............";U
  45. 450  IF U<1753 THEN GOSUB 960:GOTO 80
  46. 460  GOSUB 2040
  47. 470  PRINT "        End Year ................";USING "####";U
  48. 480  GOSUB 1980
  49. 490  INPUT " End Month No. .........";V
  50. 500  GOSUB 2040
  51. 510  PRINT "        End Month No. ...........";USING "####";V
  52. 520  MM=V:GOSUB 1200
  53. 530  GOSUB 1980
  54. 540  INPUT " End Day No. ...........";W
  55. 550  Y=U:M=V:D=W:GOSUB 1010:A$(12)=J$(Z)
  56. 560  LOCATE CSRLIN-3
  57. 570  PRINT "End date .................. ";A$(12);" "W$;STR$(W);",";U
  58. 580  PRINT U1$;:PRINT E$;:LOCATE CSRLIN-1
  59. 590  IF Y=1 THEN H=R+1925:GOTO 610
  60. 600  H=R
  61. 610  G=S:I=T
  62. 620  GOSUB 860
  63. 630  J=I
  64. 640  IF Y=1 THEN H=U+1925:GOTO 660
  65. 650  H=U
  66. 660  G=V:I=W
  67. 670  GOSUB 860
  68. 680  X=I-J
  69. 690  COLOR 0,14
  70. 700  FOR CLR=7 TO 10:LOCATE CLR,22:PRINT SPC(38):NEXT CLR:LOCATE 7,1
  71. 710  COLOR 14,6
  72. 720  LOCATE CSRLIN,22
  73. 730  PRINT " Days between dates .....";USING "#####,###";ABS(X)
  74. 740  LOCATE CSRLIN,22
  75. 750  PRINT " Weeks between dates ....";USING "#####,###.#";ABS(X)/7
  76. 760  LOCATE CSRLIN,22
  77. 770  PRINT " Months between dates ...";USING "#####,###.#";ABS(X)/365.25*12
  78. 780  LOCATE CSRLIN,22
  79. 790  PRINT " Years between dates ....";USING "#####,###.##";ABS(X)/365.25
  80. 800  COLOR 7,0
  81. 810  PRINT
  82. 820  PRINT TAB(14);"(Weeks, months & years calculated to nearest full day)
  83. 830  PRINT
  84. 840  GOTO 1270
  85. 850  '
  86. 860  IF G-3>=0 THEN Z=-(G-3)*30.6-0.5:GOSUB 940:I=I-Z:GOTO 890
  87. 870  H=H-1
  88. 880  Z=(-(G-3)-12)*30.6-0.5:GOSUB 940:I=I-Z
  89. 890  Z=H*365.25:GOSUB 940:I=I+Z
  90. 900  Z=H/100:GOSUB 940:I=I-Z
  91. 910  Z=H/400:GOSUB 940:I=I+Z
  92. 920  I=I-307:RETURN
  93. 930  '
  94. 940  X=INT(ABS(Z)):Z=SGN(Z)*X:RETURN
  95. 950  '
  96. 960  BEEP:PRINT:PRINT "Year must not be prior to 1753, the year of change from
  97. 970  PRINT "the Julian to Gregorian calendar. Press any key to continue.
  98. 980  IF INKEY$=""THEN 980
  99. 990  ERASE A$,M$:GOTO 10
  100. 1000  '
  101. 1010  J$(1)="Sunday
  102. 1020  J$(2)="Monday
  103. 1030  J$(3)="Tuesday
  104. 1040  J$(4)="Wednesday
  105. 1050  J$(5)="Thursday
  106. 1060  J$(6)="Friday
  107. 1070  J$(7)="Saturday
  108. 1080  K=INT(0.6+(1/M))
  109. 1090  L=Y-K
  110. 1100  O=M+12*K
  111. 1110  P=L/100
  112. 1120  Z1=INT(P/4)
  113. 1130  Z2=INT(P)
  114. 1140  Z3=INT((5*L)/4)
  115. 1150  Z4=INT(13*(O+1)/5)
  116. 1160  Z=Z4+Z3-Z2+Z1+D-1
  117. 1170  Z=Z-(7*INT(Z/7))+1
  118. 1180  RETURN
  119. 1190  '
  120. 1200  FOR W=1 TO 12
  121. 1210  READ W$:IF W=MM THEN RESTORE:GOTO 1230
  122. 1220  NEXT W
  123. 1230  RETURN
  124. 1240  DATA January,February,March,April,May,June
  125. 1250  DATA July,August,September,October,November,December
  126. 1260  '
  127. 1270  '.....display calendars
  128. 1280  '
  129. 1290  COLOR 7,0,0
  130. 1300  DIM LKUP$(12,2)
  131. 1310  RESTORE 1320
  132. 1320  DATA JANUARY,31,FEBRUARY,28,MARCH,31,APRIL,30,MAY,31,JUNE,30
  133. 1330  DATA JULY,31,AUGUST,31,SEPTEMBER,30,OCTOBER,31,NOVEMBER,30,DECEMBER,31
  134. 1340  FOR J=1 TO 12:FOR K=1 TO 2
  135. 1350  READ LKUP$(J,K)
  136. 1360  NEXT K:NEXT J
  137. 1370  '
  138. 1380  FOR C=1 TO 2
  139. 1390  IF C=1 THEN MGN=1 ELSE MGN=46      'left margin of calendar
  140. 1400  IF C=1 THEN MNUM%=S ELSE MNUM%=V   'month number
  141. 1410  IF C=1 THEN DAY%=T ELSE DAY%=W     'day number
  142. 1420  IF C=1 THEN Y%=R ELSE Y%=U         'year number
  143. 1430  M$=LKUP$(MNUM%,1)                  'month name
  144. 1440  MY$=M$+STR$(Y%)                    'month, year
  145. 1450  ND%=VAL(LKUP$(MNUM%,2))            'number of days in month
  146. 1460  '
  147. 1470  '....calculate calendar
  148. 1480  FLEAP%=0:                             'flag
  149. 1490  IF Y% MOD 400=0 THEN 1520             'leap year
  150. 1500  IF Y% MOD 100=0 THEN 1540             'not leap year
  151. 1510  IF Y% MOD 4<>0  THEN 1540             'not leap year
  152. 1520  FLEAP%=1: IF ND%=28 THEN ND%=29       'add day to Feb.if leap year
  153. 1530  '....get days in prior years
  154. 1540  YDAYS=365*Y%+INT((Y%-1)/4)-INT(0.75*(INT((Y%-1)/100)+1))
  155. 1550  '....add days in prior months this year
  156. 1560  MDAYS=0
  157. 1570  FOR I=1 TO MNUM%-1:MDAYS=MDAYS+VAL(LKUP$(I,2)):NEXT I
  158. 1580  '....add 1st day, this month
  159. 1590  DAYS=YDAYS+MDAYS+1
  160. 1600  '....if leap year add leap day
  161. 1610  IF FLEAP%=1 AND MNUM%>2 THEN DAYS=DAYS+1
  162. 1620  DW%=DAYS+INT(-DAYS/7)*7+6:            'calculate dayweek factor
  163. 1630  '
  164. 1640  '....display calendar
  165. 1650  LOCATE 14,MGN:COLOR 15,3
  166. 1660  PRINT SPC(35)
  167. 1670  T=INT((35-LEN(MY$))/2)
  168. 1680  LOCATE 14,MGN+T
  169. 1690  PRINT MY$
  170. 1700  COLOR 10,4
  171. 1710  LOCATE 15,MGN:PRINT " SUN  MON  TUE  WED  THU  FRI  SAT "
  172. 1720  CS%=1                              'counts spaces
  173. 1730  '
  174. 1740  COLOR 0,6:FOR Z=16 TO 22:LOCATE Z,MGN:PRINT SPC(35):NEXT Z
  175. 1750  FOR R%=16 TO 22                    'row
  176. 1760  FOR C%=2 TO 32 STEP 5              'column
  177. 1770  CD%=CS%-DW%
  178. 1780  IF CD%=DAY% THEN COLOR 15,1  ELSE COLOR 15,6  'hi-lite specified day
  179. 1790  '....CD%=dates, ND%=days in month
  180. 1800  IF CD%<1 OR CD%>ND% THEN 1850      'bad dates
  181. 1810  CD$=STR$(CD%)
  182. 1820  CD$=RIGHT$(CD$,LEN(CD$)-1)         'remove blank space
  183. 1830  IF LEN(CD$)<2 THEN CD$=" "+CD$
  184. 1840  LOCATE R%,C%+MGN:PRINT CD$
  185. 1850  CS%=CS%+1
  186. 1860  NEXT C%:NEXT R%
  187. 1870  '
  188. 1880  COLOR 15,3
  189. 1890  IF C=1 THEN Q$="START  DATE":Q=12
  190. 1900  IF C=2 THEN Q$="END  DATE":Q=13
  191. 1910  LOCATE 22,MGN:PRINT SPC(35)
  192. 1920  LOCATE 22,MGN+Q:PRINT Q$
  193. 1930  NEXT C
  194. 1940  '
  195. 1950  '.....end
  196. 1960  COLOR 7,0:GOSUB 2100:CLS:CHAIN "caltoday,200"
  197. 1970  '
  198. 1980  '.....input routine
  199. 1990  COLOR 0,7
  200. 2000  PRINT " ENTER:";
  201. 2010  COLOR 7,0
  202. 2020  RETURN
  203. 2030  '
  204. 2040  '.....erase current line
  205. 2050  LOCATE CSRLIN-1
  206. 2060  PRINT E$;
  207. 2070  LOCATE CSRLIN-1
  208. 2080  RETURN
  209. 2090  '
  210. 2100  'HARDCOPY
  211. 2110  GOSUB 2220:LOCATE 25,2:COLOR 14,6
  212. 2120  PRINT " Press 1 to print screen, 2 to print screen & ";
  213. 2130  PRINT "advance paper, or 3 to continue.";:COLOR 7,0
  214. 2140  Z$=INKEY$:IF Z$="3"THEN GOSUB 2220:RETURN
  215. 2150  IF Z$="1"OR Z$="2"THEN GOSUB 2220:GOTO 2170
  216. 2160  GOTO 2140
  217. 2170  FOR QX=1 TO 24:FOR QY=1 TO 80
  218. 2180  LPRINT CHR$(SCREEN(QX,QY));
  219. 2190  NEXT QY:NEXT QX
  220. 2200  IF Z$="2"THEN LPRINT CHR$(12)
  221. 2210  GOTO 2110
  222. 2220  LOCATE 25,1:PRINT STRING$(80,32);:RETURN
  223.